home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / control.lisp < prev    next >
Encoding:
Text File  |  1991-12-11  |  8.4 KB  |  219 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: control.lisp,v 1.10 91/12/11 16:48:42 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    The control analysis pass in the compiler.  This pass determines the
  15. ;;; order in which the IR2 blocks are to be emitted, attempting to minimize the
  16. ;;; associated branching costs.
  17. ;;;
  18. ;;;    At this point, we commit to generating IR2 (and ultimately assembler)
  19. ;;; for reachable blocks.  Before this phase there might be blocks that are
  20. ;;; unreachable but still appear in the DFO, due in inadequate optimization,
  21. ;;; etc.
  22. ;;;
  23. ;;; Written by Rob MacLachlan
  24. ;;;
  25. (in-package 'c)
  26.  
  27.  
  28. ;;; Add-To-Emit-Order  --  Interface
  29. ;;;
  30. ;;;    Insert Block in the emission order after the block After.
  31. ;;;
  32. (defun add-to-emit-order (block after)
  33.   (declare (type ir2-block block after))
  34.   (let ((next (ir2-block-next after)))
  35.     (setf (ir2-block-next after) block)
  36.     (setf (ir2-block-prev block) after)
  37.     (setf (ir2-block-next block) next)
  38.     (setf (ir2-block-prev next) block))
  39.   (undefined-value))
  40.  
  41.  
  42. ;;; FIND-ROTATED-LOOP-HEAD  --  Internal
  43. ;;;
  44. ;;;    If Block looks like the head of a loop, then attempt to rotate it.  A
  45. ;;; block looks like a loop head if the number of some predecessor is less than
  46. ;;; the block's number.  Since blocks are numbered in reverse DFN, this will
  47. ;;; identify loop heads in a reducible flow graph.
  48. ;;;
  49. ;;;    When we find a suspected loop head, we scan back from the tail to find
  50. ;;; an alternate loop head.  This substitution preserves the correctness of the
  51. ;;; walk, since the old head can be reached from the new head.  We determine
  52. ;;; the new head by scanning as far back as we can find increasing block
  53. ;;; numbers.  Beats me if this is in general optimal, but it works in simple
  54. ;;; cases.
  55. ;;;
  56. ;;; This optimization is inhibited in functions with NLX EPs, since it is hard
  57. ;;; to do this without possibly messing up the special-case walking from NLX
  58. ;;; EPs described in CONTROL-ANALYZE-1-FUN.  We also suppress rotation of loop
  59. ;;; heads which are the start of a function (i.e. tail calls), as the debugger
  60. ;;; wants functions to start at the start.
  61. ;;;
  62. (defun find-rotated-loop-head (block)
  63.   (declare (type cblock block))
  64.   (let* ((num (block-number block))
  65.      (env (block-environment block))
  66.      (pred (dolist (pred (block-pred block) nil)
  67.          (when (and (not (block-flag pred))
  68.                 (eq (block-environment pred) env)
  69.                 (< (block-number pred) num))
  70.            (return pred)))))
  71.     (cond
  72.      ((and pred
  73.        (not (environment-nlx-info env))
  74.        (not (eq (node-block (lambda-bind (block-home-lambda block)))
  75.             block)))
  76.       (let ((current pred)
  77.         (current-num (block-number pred)))
  78.     (block DONE
  79.       (loop
  80.         (dolist (pred (block-pred current) (return-from DONE))
  81.           (when (eq pred block)
  82.         (return-from DONE))
  83.           (when (and (not (block-flag pred))
  84.              (eq (block-environment pred) env)
  85.              (> (block-number pred) current-num))
  86.         (setq current pred   current-num (block-number pred))
  87.         (return)))))
  88.     (assert (not (block-flag current)))
  89.     current))
  90.      (t
  91.       block))))
  92.       
  93.  
  94. ;;; Control-Analyze-Block  --  Internal
  95. ;;;
  96. ;;;    Do a graph walk linking blocks into the emit order as we go.  We call
  97. ;;; FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
  98. ;;;
  99. ;;;    We treat blocks ending in tail local calls to other environments
  100. ;;; specially.  We can't walked the called function immediately, since it is in
  101. ;;; a different function and we must keep the code for a function contiguous.
  102. ;;; Instead, we return the function that we want to call so that it can be
  103. ;;; walked as soon as possible, which is hopefully immediately.
  104. ;;;
  105. ;;;    If any of the recursive calls ends in a tail local call, then we return
  106. ;;; the last such function, since it is the only one we can possibly drop
  107. ;;; through to.  (But it doesn't have to be from the last block walked, since
  108. ;;; that call might not have added anything.)
  109. ;;;
  110. ;;;    We defer walking successors whose successor is the component tail (end
  111. ;;; in an error, NLX or tail full call.)  This is to discourage making error
  112. ;;; code the drop-through.
  113. ;;;
  114. (defun control-analyze-block (block tail)
  115.   (declare (type cblock block) (type ir2-block tail))
  116.   (unless (block-flag block)
  117.     (let ((block (find-rotated-loop-head block)))
  118.       (setf (block-flag block) t)
  119.       (assert (and (block-component block) (not (block-delete-p block))))
  120.       (add-to-emit-order (or (block-info block)
  121.                  (setf (block-info block) (make-ir2-block block)))
  122.              (ir2-block-prev tail))
  123.       
  124.       (let ((last (block-last block)))
  125.     (cond ((and (combination-p last) (node-tail-p last)
  126.             (eq (basic-combination-kind last) :local)
  127.             (not (eq (node-environment last)
  128.                  (lambda-environment (combination-lambda last)))))
  129.            (combination-lambda last))
  130.           (t
  131.            (let ((component-tail (component-tail (block-component block)))
  132.              (block-succ (block-succ block))
  133.              (fun nil))
  134.          (dolist (succ block-succ)
  135.            (unless (eq (first (block-succ succ)) component-tail)
  136.              (let ((res (control-analyze-block succ tail)))
  137.                (when res (setq fun res)))))
  138.          (dolist (succ block-succ)
  139.            (control-analyze-block succ tail))
  140.          fun)))))))
  141.  
  142.  
  143. ;;; CONTROL-ANALYZE-1-FUN  --  Internal
  144. ;;;
  145. ;;;    Analyze all of the NLX EPs first to ensure that code reachable only from
  146. ;;; a NLX is emitted contiguously with the code reachable from the Bind.  Code
  147. ;;; reachable from the Bind is inserted *before* the NLX code so that the Bind
  148. ;;; marks the beginning of the code for the function.  If the walks from NLX
  149. ;;; EPs reach the bind block, then we just move it to the beginning.
  150. ;;;
  151. ;;;    If the walk from the bind node encountered a tail local call, then we
  152. ;;; start over again there to help the call drop through.  Of course, it will
  153. ;;; never get a drop-through if either function has NLX code.
  154. ;;;
  155. (defun control-analyze-1-fun (fun component)
  156.   (declare (type clambda fun) (type component component))
  157.   (let* ((tail-block (block-info (component-tail component)))
  158.      (prev-block (ir2-block-prev tail-block))
  159.      (bind-block (node-block (lambda-bind fun))))
  160.     (unless (block-flag bind-block)
  161.       (dolist (nlx (environment-nlx-info (lambda-environment fun)))
  162.     (control-analyze-block (nlx-info-target nlx) tail-block))
  163.       (cond
  164.        ((block-flag bind-block)
  165.     (let* ((2block (block-info bind-block))
  166.            (prev (ir2-block-prev 2block))
  167.            (next (ir2-block-next 2block)))
  168.       (setf (ir2-block-prev next) prev)
  169.       (setf (ir2-block-next prev) next)
  170.       (add-to-emit-order 2block prev-block)))
  171.        (t
  172.     (let ((new-fun (control-analyze-block bind-block
  173.                           (ir2-block-next prev-block))))
  174.       (when new-fun
  175.         (control-analyze-1-fun new-fun component)))))))
  176.   (undefined-value))
  177.  
  178.   
  179. ;;; Control-Analyze  --  Interface
  180. ;;;
  181. ;;;    Do control analysis on Component, finding the emit order.  Our only
  182. ;;; cleverness here is that we walk XEP's first to increase the probability
  183. ;;; that the tail call will be a drop-through.
  184. ;;;
  185. ;;;    When we are done, we delete blocks that weren't reached by the walk.
  186. ;;; Some return blocks are made unreachable by LTN without setting
  187. ;;; COMPONENT-REANALYZE.  We remove all deleted blocks from the IR2-COMPONENT
  188. ;;; VALUES-RECEIVERS to keep stack analysis from getting confused.
  189. ;;;
  190. (defun control-analyze (component)
  191.   (let* ((head (component-head component))
  192.      (head-block (make-ir2-block head))
  193.      (tail (component-tail component))
  194.      (tail-block (make-ir2-block tail)))
  195.     (setf (block-info head) head-block)
  196.     (setf (block-info tail) tail-block)
  197.     (setf (ir2-block-prev tail-block) head-block)
  198.     (setf (ir2-block-next head-block) tail-block)
  199.  
  200.     (clear-flags component)
  201.  
  202.     (dolist (fun (component-lambdas component))
  203.       (when (external-entry-point-p fun)
  204.     (control-analyze-1-fun fun component)))
  205.  
  206.     (dolist (fun (component-lambdas component))
  207.       (control-analyze-1-fun fun component))
  208.  
  209.     (do-blocks (block component)
  210.       (unless (block-flag block)
  211.     (delete-block block))))
  212.  
  213.   (let ((2comp (component-info component)))
  214.     (setf (ir2-component-values-receivers 2comp)
  215.       (delete-if-not #'block-component
  216.              (ir2-component-values-receivers 2comp))))
  217.  
  218.   (undefined-value))
  219.